Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/keep.zip/KEEP.PAS

Pascal/Delphi Source File | 1991-12-19 | 11KB | 483 lines

program keep;

{-----------------------------------------------------------------------------
 -                                                                           -
 -  KEEP.PAS                                                                 -
 -                                                                           -
 -    Author: Rick Owen                                                      -
 -    Date  : 12/17/91                                                       -
 -    Keep:                                                                  -
 -     1) parses the command line for file names (or file specs)             -
 -     2) sets the hidden attribute on all files that match the              -
 -        specification(s)                                                   -
 -     3) deletes all other files in the directory, and                      -
 -     4) resets the hidden attribute on the files that were prev-           -
 -        iously hidden.                                                     -
 -  These programs carry no warranties either expressed or implied.  I       -
 -  assume no liability of any kind [use at YOUR risk].  Any program         -
 -  which deletes files is inherently dangerous and you should be            -
 -  extremely careful when using either KEEP or MASSDEL.  You are free to    -
 -  use both programs however you wish, and you may freely distribute        -
 -  copies of either program, as long as you do not charge for it [connect   -
 -  charges to BBSes are excluded from this restriction].                    -
 -----------------------------------------------------------------------------}

uses dos, crt;

const

  MAXFILES  = 500;
  MAXPARMS  = 50;
  ReadOnly  = $01;
  Hidden    = $02;
  SysFile   = $04;
  VolumeID  = $08;
  Directory = $10;
  Archive   = $20;

type

  miniSearchRec = record
    time : longint;
    size : longint;
    name : string[12];
  end; { record }
  fileList    = array[1..MAXFILES] of miniSearchRec;

var
  files       : fileList;
  fileParms   : array[1..MAXPARMS] of String[12];
  confirm     : boolean;
  silent      : boolean;
  fileCount   : word;
  parmCount   : word;

procedure help;

begin { help }

  writeln('keep v1.0 - delete all files except those specified.');
  writeln('usage: keep [-d] [-s] filespec1 [filespec2 ... filespecN]');
  writeln('   -d = dangerous mode (no confirm)');
  writeln('   -s = silent mode (no report as files are deleted)');
  writeln('        defaults : confirm and not silent');
  writeln;
  writeln('Keep was written in Turbo Pascal V6.0 by Rick Owen');
  writeln('Revision level = 0, Release date = 12/17/91.');
  halt(1);

end { help };

procedure miniHelp;

begin { miniHelp }

  writeln;
  writeln(' y - yes, delete file');
  writeln(' n - no, do not delete file');
  writeln(' q - no, do not delete file and terminate the program');
  writeln(' c - yes, delete file and continue without further confirmation');
  writeln(' l - list remaining files which will not be kept');
  writeln(' k - list kept files');
  writeln;

end; {miniHelp }

procedure getParameters;

var
  parmLoop    : Word;
  parm        : string[1];

begin { getParameters }

  if (ParamCount < 0) or (ParamCount > MAXPARMS) then
  begin
    help; { we don't return from help }
  end
  else
  begin

    confirm   := true;
    silent    := false;
    parmCount := 1;

    for parmLoop := 1 to ParamCount do
    begin
      if copy(ParamStr(parmLoop),1,1) = '-' then
      begin
        { this is a parameter }
        parm := copy(ParamStr(parmLoop),2,1);
        if ((parm = 's') or (parm = 'S')) then
          silent := true;
        if ((parm = 'd') or (parm = 'D')) then
          confirm := false;
        if (pos(parm,'sSdD') = 0) then
        begin
          write('Unknown parameter - ignored');
          writeln;
        end
      end
      else
      begin
        fileParms[parmCount] := ParamStr(parmLoop);
        inc(parmCount);
      end
    end; { loop }
    dec(parmCount);
    if parmCount = 0 then
      help;
  end; { for }

end; { getParameters }

function LeadingZero(w : Word) : String;

var
  s : String;

begin { LeadingZero }

  Str(w:0,s);
  if Length(s) = 1 then
    s := '0' + s;
  LeadingZero := s;

end; { LeadingZero }

function hideFile( fileName : string ) : word;


var
  f: file;

begin { hideFile }

  Assign(f, fileName);
  SetFAttr(f, Hidden);
  hideFile := DosError;

end; { hideFile }

procedure unHideFiles( files : fileList; lastFile : word);

var
  f         : file;
  attr      : Word;
  fileLoop  : word;

begin

  for fileLoop := 1 to lastFile do
  begin

    Assign(f, files[fileLoop].name);
    GetFAttr(f, attr);

    if attr and Hidden <> 0 then
    begin

      attr := attr xor Hidden;
      SetFAttr(f, attr);

    end;

  end; { for }

end; { unHideFiles }

procedure writeFileData( dta : miniSearchRec );

var
  dt        : DateTime;

begin { writeFileData }

    write(dta.name:12);
    write(dta.size:8);
    write(' ');
    UnpackTime(dta.time,dt);
    with dt do
    begin
      Write(' ',LeadingZero(day), '/',LeadingZero(month),'/',
            LeadingZero(year));
      Write(' ', LeadingZero(hour),':',
            LeadingZero(min),':', LeadingZero(sec));
      Write(' ');
    end;

end; { writeFileData }

procedure listRemainingFiles( dta : SearchRec );

var
  t           : SearchRec;
  x           : miniSearchRec;
  lineCount   : word;
  ch          : Char;

begin { listRemainingFiles }

  move(dta, t, SizeOf(t));

  writeln;
  lineCount := 2;
  writeln('───────────── Start of List ─────────────');

  repeat


    move(t.name, x.name, SizeOf(dta.name));
    x.size := t.size;
    x.time := t.time;
    writeFileData( x );
    writeln;
    inc(lineCount);
    if lineCount > 24 then
    begin
      write('───────── pausing - press a key ─────────');
      ch := readKey;
      writeln;
      lineCount := 1;
    end;
    findNext( t );

  until DosError <> 0;

  writeln('────────────── End of List ──────────────');

end; { listRemainingFiles }

procedure listKeptFiles;

var
  lineCount   : word;
  ch          : Char;
  fileLoop    : word;

begin { listKeptFiles }


  writeln;
  lineCount := 2;
  writeln('───────────── Start of List ─────────────');

  for fileLoop := 1 to fileCount do
  begin

    writeFileData( files[fileLoop] );
    writeln;
    inc(lineCount);
    if lineCount > 24 then
    begin
      write('───────── pausing - press a key ─────────');
      ch := readKey;
      writeln;
      lineCount := 1;
    end;

  end; { for }

  writeln('────────────── End of List ──────────────');

end; { listKeptFiles }

procedure writePrompt;
begin { writePrompt }
  Write(' : delete (y/N/q/c/l/k/?) ');
end; { writePrompt }

procedure deleteTheFiles;

var
  fileLoop    : Word;
  dta         : SearchRec;
  listDta     : miniSearchRec;
  dt          : DateTime;
  confirmKey  : char;
  doExit      : boolean;
  doStop      : boolean;
  deleteIt    : boolean;
  f           : file;

begin { deleteTheFiles }

  fileCount := 1;

  for fileLoop := 1 to parmCount do
  begin

    findfirst(fileParms[fileLoop], Archive, dta);
    while DosError = 0 do
    begin

      move(dta.name, files[fileCount].name, SizeOf(dta.name));
      files[fileCount].size := dta.size;
      files[fileCount].time := dta.time;

      if hideFile(dta.name) > 0 then
      begin
        writeln('Error while hiding files');
        unHideFiles(files, fileCount - 1);
        halt(3);
      end;
      inc(fileCount);
      if fileCount > MAXFILES then
      begin
        writeln('Maximum number of files exceeded!');
        unHideFiles(files, fileCount - 1);
        halt(2);
      end;

      findnext(dta);

    end; { while }

  end; { for }

  dec(fileCount);

  if fileCount = 0 then
  begin

    Write('No files found matching keep parameters.  Delete ALL files (y/N) ?');
    doExit := true;
    doStop := true;

    repeat

        confirmKey := upcase(readkey);

        case confirmKey of

          'Y'     : begin
                    doExit := true;
                    doStop := false
                  end;
          'N',#13, 'Q', #27
                : begin
                    doExit := true;
                    doStop := true;
                  end;

        end; { case }

      until doExit;

    if doStop then
      halt(4);

    writeln;

  end;


  { now we delete all those that remain }

  findfirst('*.*', Archive, dta);
  while DosError = 0 do
  begin
    deleteIt := true;
    doStop   := false;
      if confirm then
      begin
      deleteIt := false;
        doExit := false;

      move(dta.name, listDta.name, SizeOf(dta.name));
      listDta.size := dta.size;
      listDta.time := dta.time;
      writeFileData( listDta );
      writePrompt;

        repeat

          confirmKey := upcase(readkey);

          case confirmKey of
            'Y'     : begin
                      deleteIt := true;
                      doExit   := true
                    end;
            'N',#13 : doExit := true;
            'Q',#27 : begin
                      doExit := true;
                      doStop := true;
                    end;
          'L'     : begin
                      listRemainingFiles( dta );
                      writeFileData( listDta );
                      writePrompt;
                    end;
          'K'     : begin
                      listKeptFiles;
                      writeFileData( listDta );
                      writePrompt;
                    end;
            'C'     : begin
                        doExit   := true;
                      deleteIt := true;
                        confirm  := false
                      end;
            '?'     : begin
                      miniHelp;
                      writeFileData( listDta );
                      writePrompt;
                    end;

          else      doExit := false;

          end; { case }

        until doExit;
      writeln;
      end;

    if doStop then
    begin

      unHideFiles(files, fileCount);
      halt(5);

    end;

    if deleteIt then
    begin

      Assign(f, dta.name);
      {$I-}
      Reset(f);
      {$I+}
      if IOResult <> 0 then
      begin
        WriteLn('Cannot find ', dta.name);
        unHideFiles(files, fileCount);
        halt(6);
      end
      else
      begin
        Close(f);
        if not silent then
          writeln('  deleting ', dta.name);
       Erase(f);
      end;

    end;

    findnext(dta);

  end; { while }

  unHideFiles(files, fileCount);

end { deleteTheFiles } ;

begin { keep }

  CheckBreak := false;
  getParameters;
  deleteTheFiles;

end { keep }.